#!/usr/bin/perl -s

##
## Copyright 2008 Adriana Lukas & Alec Muffett
##
## Licensed under the Apache License, Version 2.0 (the "License"); you
## may not use this file except in compliance with the License. You
## may obtain a copy of the License at
##
## http://www.apache.org/licenses/LICENSE-2.0
##
## Unless required by applicable law or agreed to in writing, software
## distributed under the License is distributed on an "AS IS" BASIS,
## WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
## implied. See the License for the specific language governing
## permissions and limitations under the License.
##

# performs a sweep of perl scripts given as arguments, looking for
# undefined function calls

# usage: perllint [-v] file ...

$pkg = "";

while (<>) {
    if (/^\s*package\s+(\w+)/o) {
	$pkg = " package $1";
    }

    push(@lines, [ $_, "$ARGV:$.$pkg" ] );
    if (eof) {
	close ARGV; # reset $.
	$pkg = "";
    }
}

foreach $input (@lines) {
    ($line, $debug) = @{$input};

    if ($line =~ s!^#\s*\$LINT\s*!!o) {
	my ($cmd, $sym, @notes) = split(" ", $line);

	warn "$0: pragma $cmd $sym\n";

	if ($cmd eq 'external') {
	    push(@{$defns{$sym}}, "$debug [PRAGMA] @notes");
	}
	elsif ($cmd eq 'reference') {
	    push(@{$calls{$sym}}, "$debug [PRAGMA] @notes");
	}
	else {
	    die "$0: bad pragma at $debug: $line\n";
	}
	next;
    }

    $line =~ s!#.*!!o;

    if ($line =~ /^\s*sub\s+(\w+)/o) {
	push(@{$defns{$1}}, $debug);
    }

    while ($line =~ s!(\w+(->|::))+(\w+)!!o) {
	push(@{$calls{$3}}, $debug);
    }

    while ($line =~ s!\&(\w+)!!o) {
	push(@{$calls{$1}}, $debug);
    }
}


foreach $loop (0..1) {
    print "**** UNDEFINED ROUTINES\n\n" if ($loop == 0);
    print "**** MULTIPLY-DEFINED ROUTINES\n\n" if ($loop == 1);

    foreach $call (sort keys %calls) {
	$ndefns = ($#{$defns{$call}} + 1);
	@xdefns = @{$defns{$call}};
	$ncalls = ($#{$calls{$call}} + 1);
	@xcalls = @{$calls{$call}};

	if (($loop == 0) and ($ndefns == 0)) {
	    print "$call undefined, called at:\n\t";
	    print join("\n\t", @xcalls);
	    print "\n\n";
	}
	elsif (($loop == 1) and ($ndefns > 1)) {
	    print "$call defined $ndefns times:\n\t";
	    print join("\n\t", @xdefns);
	    print "\n\n";
	}

    }
}
print "\n";

foreach $loop (0..1) {
    print "**** UNCALLED ROUTINES\n\n" if ($loop == 0);
    print "**** MULTIPLY-CALLED ROUTINES\n\n" if ($v and $loop == 1);

    foreach $defn (sort keys %defns) {
	$ncalls = ($#{$calls{$defn}} + 1);
	@xcalls = @{$calls{$defn}};

	$ndefns = ($#{$defns{$defn}} + 1);
	@xdefns = @{$defns{$defn}};

	if (($loop == 0) and ($ncalls == 0)) {
	    print "$defn uncalled, defined at:\n\t";
	    print join("\n\t", @xdefns);
	    print "\n\n";
	}
	elsif ($v and ($loop == 1) and ($ncalls > 1)) {
	    print "$defn called $ncalls times:\n\t";
	    print join("\n\t", @xcalls);
	    print "\n\n";
	}

    }
}
print "\n";

exit 0;
